; ORIGINAL: 3dt2.1/examples/schemers/bendwire.scm
;;
;; bendwire.scm
;;
;; A collection of programs that fulfill the goals of the BENDING WIRES
;; project in Chapter 4 of the "Getting Started" book.
;;
;; Edward C. Martin, Schemers Inc.
;; 31 January 1994
;; 08 November 1994, removed all mention of the void object,
;; for compatibility with Elk 2.2
;;

;; Clear the slate.
;;
(part:clear)
(for-each view:delete (env:views))

;; Create a standard view.
;;
(load "std-view.scm")

;; Load some basic coloring and rendering procedures.
;;
(load "rdrpaint.scm")

;; A simple utility to translate from radians to degrees.
;;
(define radians->degrees
  (lambda (rads)
    (* (/ rads PI) 180)))

;; (make-wire-object axis-pos axis-gvec wire-rad) :  creates a wire-object
;; whose wire is a cylinder with radius  wire-rad,  base center at  axis-pos,
;; and central axis given both in length and direction by  axis-gvec.
;; The wire-object is capable of responding to a variety of messages, as
;; shown in the cond-expression below.
;;
(define make-wire-object
  (lambda (axis-pos axis-gvec wire-rad)
    (let ((wire (solid:cylinder
                  axis-pos (position:offset axis-pos axis-gvec) wire-rad))
          (axis-unit-gvec (gvector:unitize axis-gvec))
          (dist-to-end (gvector:length axis-gvec)))
      (lambda (msg)
        (cond
          ((equal? msg 'get-wire) wire)
          ((equal? msg 'set-wire)
           (lambda (new-wire) (set! wire new-wire) 'ok))
          ((equal? msg 'get-rad) wire-rad)
          ((equal? msg 'get-axispos) axis-pos)
          ((equal? msg 'set-axispos)
           (lambda (new-pos) (set! axis-pos new-pos) 'ok))
          ((equal? msg 'get-axisuvec) axis-unit-gvec)
          ((equal? msg 'set-axisuvec)
           (lambda (new-vec) (set! axis-unit-gvec new-vec) 'ok))
          ((equal? msg 'get-tail) dist-to-end)
          ((equal? msg 'set-tail)
           (lambda (new-tail-lng) (set! dist-to-end new-tail-lng) 'ok))
          (else (error 'wire-object "Unrecognized message: ~a" msg)))))))


;; (bender wire-obj dist-to-bend bend-rad post-bend-axis)  or, when
;;    post-bend-axis  is the reverse of the current axis direction,
;; (bender wire-obj dist-to-bend bend-rad post-bend-axis axis)  bends a
;;    wire in accordance with the following interpretation of the arguments:
;;
;;  wire-obj        the wire-object whose wire is to be bent
;;
;;  dist-to-bend    the distance along the axis from the wire's current
;;                  axis position to the start of the bend
;;
;;  bend-rad        the radius of the bend, measured from the axis about
;;                  which bending takes place to the outside of the wire
;;
;;  post-bend-axis  a gvector giving the desired direction of the straight
;;                  tail of the wire after the bend has happened
;;
;;  axis            a gvector giving the axis about which bending is to take
;;                  place. (This is ignored unless the  post-bend-axis
;;                  direction is the reverse of the current axis direction.
;;                  But in that case it is essential.)
;;
(define bender
  (lambda (wire-obj dist-to-bend bend-rad post-bend-axis . axis)
    (let ((dist-to-end (wire-obj 'get-tail)))
      (if (> dist-to-bend dist-to-end)
          (format #t "You only have ~s units of wire left." dist-to-end)
          (let* ((axis-pos (wire-obj 'get-axispos))
                 (axis-uvec (wire-obj 'get-axisuvec))
                 (wire-rad (wire-obj 'get-rad))
                 (bend-angle (acos (gvector:dot
                                     axis-uvec
                                     (gvector:unitize post-bend-axis))))
                 (bend-spine-length
                   (* (+ wire-rad bend-rad) bend-angle))
                 (new-dist-to-end
                   (- dist-to-end dist-to-bend bend-spine-length)))
            (if (< new-dist-to-end 0)
                (begin
                  (display "There is not enough wire left ")
                  (display "for you to make that bend."))
                (let* ((wire (wire-obj 'get-wire))
                       (bend-start-pos
                         (position:offset
                           axis-pos
                           (gvector:scale axis-uvec dist-to-bend)))
                       (end-pos (position:offset
                                  axis-pos
                                  (gvector:scale axis-uvec dist-to-end)))
                       (stump (solid:subtract
                                wire
                                (solid:cylinder
                                  bend-start-pos end-pos wire-rad)))
                       (bend-axis
                         (if (gvector:parallel? axis-uvec post-bend-axis)
                             (car axis)
                             (gvector:cross axis-uvec post-bend-axis)))
                       (bend-ctr-pos
                         (position:offset
                           bend-start-pos
                           (gvector:scale
                             (gvector:unitize
                               (gvector:cross bend-axis axis-uvec))
                             (+ wire-rad bend-rad))))
                       (bend (transform:rotation
                               bend-ctr-pos bend-axis
                               (radians->degrees bend-angle)))
                       (bend-face (find-planar-face stump bend-start-pos)))
                  ((wire-obj 'set-wire)
                   (begin
                     (solid:revolve-face
                       bend-face bend-ctr-pos bend-axis
                       (radians->degrees bend-angle))
                     (solid:sweep-face bend-face new-dist-to-end)))
                  ((wire-obj 'set-axispos)
                   (position:transform bend-start-pos bend))
                  ((wire-obj 'set-axisuvec)
                   (gvector:unitize post-bend-axis))
                  ((wire-obj 'set-tail) new-dist-to-end)
                  )))))))

;;
;; (find-planar-face solid pos)  returns the planar-face of the given solid
;; on which the given position lies (if any).
;;
(define find-planar-face
  (lambda (solid pos)
    (let ((faces (filter:apply (filter:type "face:planar?")
                               (entity:faces solid))))
      (letrec ((search
                 (lambda (slist)
                   (if (null? slist)
                       (display "The given position is not on a face.")
                       (let* ((next (car slist))
                              (face-ray (face:plane-ray next))
                              (next-pos (ray:position face-ray))
                              (next-norm (ray:gvector face-ray)))
                         (if (or (equal? pos next-pos)
                                 (gvector:perpendicular?
                                   (gvector:from-to pos next-pos)
                                   next-norm))
                             next
                             (search (cdr slist))))))))
        (search faces)))))

;; Two sample programs, demonstrating the use of the  bender  procedure.
;;
(define paperclip               ; an argument of 100 produces the figure in the
  (lambda (t clr-int)           ; Getting Started book
    (let ((B (make-wire-object (position (* -0.25 t) 0 (* 0.1 t))
                               (gvector (* 3.65 t) 0 0) (* 0.02 t))))
      (bender B (* 0.4 t) (* 0.08 t) (gvector -1 0 0) (gvector 0 1 0))
      (bender B (* 0.55 t) (* 0.11 t) (gvector 1 0 0) (gvector 0 1 0))
      (bender B (* 0.8 t) (* 0.14 t) (gvector -1 0 0) (gvector 0 1 0))
      (entity:paint (B 'get-wire) clr-int)
      (render)
      (B 'get-wire))))

(define bent-wire
  (lambda ()
    (let  ((B (make-wire-object (position -30 -30 -30) (gvector 0 0 360) 3)))
      (bender B 40 10 (gvector 0 1 0))
      (bender B 40 5 (gvector 1 -60 0 "polar"))
      (bender B 30 10 (gvector 1 1 1))
      (bender B 20 5 (gvector 0 1 0))
      (bender B 10 5 (gvector 0 0 -1))
      (bender B (+ (position:z (B 'get-axispos)) 24) 10 (gvector -1 -1 0))
      (bender B 5 5 (gvector 0 -1 0))
      (entity:paint (B 'get-wire) YELLOW)
      (render)
      (B 'get-wire))))

;; end of file  bendwire.scm
